HPAVC/HPAVC CD-ROM.iso/pc/PASWIZ14.ZIP/SOURCE.ZIP/STRINGS.PAS

Pascal/Delphi Source File | 1993-02-28 | 9.9 KB | 406 lines

{   +----------------------------------------------------------------------+
    |                                                                      |
    |        PasWiz  Copyright (c) 1990-1993  Thomas G. Hanlin III         |
    |             3544 E. Southern Ave. #104,  Mesa, AZ 85204              |
    |                                                                      |
    |                     The Pascal Wizard's Library                      |
    |                                                                      |
    +----------------------------------------------------------------------+



Strings:

   This unit provides extensions to Pascal's rather minimal string support.
   This includes string trimming, substring extraction, uppercase/lowercase
   conversions (handles names, too), simple encryption and compression,
   assorted searches, advanced comparisons, and other useful tools.

}



UNIT Strings;



INTERFACE



FUNCTION Bickel (St1, St2: String): Integer;
FUNCTION BSq (St: String): String;
FUNCTION BUsq (St: String): String;
FUNCTION Cipher (St, Passwd: String): String;
FUNCTION CipherP (St, Passwd: String): String;
FUNCTION Crunch (SubSt, St: String): String;
FUNCTION Dupe (Count: Integer; SubSt: String): String;
FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
FUNCTION Left (St: String; Len: Integer): String;
FUNCTION LowerCase (St: String): String;
FUNCTION LTrim (St: String): String;
FUNCTION NameCase (St: String): String;
FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
FUNCTION Reverse (St: String): String;
FUNCTION Right (St: String; Len: Integer): String;
FUNCTION RPos (SubSt, St: String): Integer;
FUNCTION RTrim (St: String): String;
FUNCTION Soundex (St: String): String;
FUNCTION StripCh (ChList, St: String): String;
FUNCTION StripSt (SubSt, St: String): String;
FUNCTION StripType (ChType: Integer; St: String): String;
FUNCTION TypePos (ChType: Integer; St: String): Integer;
FUNCTION UpperCase (St: String): String;



{ --------------------------------------------------------------------------- }



IMPLEMENTATION



{$F+}

{ routines in assembly language }

FUNCTION Bickel; external;           { string comparison by Bickel method }
{$L BICKEL}

FUNCTION LowerCase; external;        { convert to lowercase }
{$L LOCASE}

FUNCTION NameCase; external;         { capitalize a name appropriately }
{$L NAMECASE}

FUNCTION UpperCase; external;        { convert to uppercase }
{$L UPCASE}

FUNCTION Reverse; external;          { reverse a string }
{$L REVERSE}

FUNCTION Soundex; external;          { string comparison by Soundex method }
{$L SOUNDEX}

FUNCTION TypePos; external;          { seek a given type of character }
{$L TYPEPOS}



{ compress spaces in a string }
FUNCTION BSq (St: String): String;
VAR
   SqSt: String;
   Ptr, RepCount: Integer;
BEGIN
   SqSt := '';
   RepCount := 0;
   FOR Ptr := 1 TO Length(St) DO
      IF St[Ptr] = ' ' THEN
         INC(RepCount)
      ELSE BEGIN
         CASE RepCount OF
            0: ;
            1: IF Ptr = 2 THEN
                  SqSt := ' '
               ELSE
                  SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
            2: SqSt := SqSt + CHR(ORD(' ') OR $80);
            ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
         END;
         SqSt := SqSt + St[Ptr];
         RepCount := 0;
      END;
   { flush any remaining spaces }
   CASE RepCount OF
      0: ;
      1: IF St = ' ' THEN
            SqSt := ' '
         ELSE
            SqSt[Length(SqSt)] := CHR(ORD(SqSt[Length(SqSt)]) OR $80);
      2: SqSt := SqSt + CHR(ORD(' ') OR $80)
      ELSE SqSt := SqSt + CHR($80) + CHR((RepCount - 3) OR $80);
   END;
   BSq := SqSt;
END;



{ uncompress a string processed by BSq }
FUNCTION BUsq (St: String): String;
VAR
   UnsqSt: String;
   Ptr: Integer;
BEGIN
   UnsqSt := '';
   Ptr := 1;
   WHILE Ptr <= Length(St) DO
      CASE ORD(St[Ptr]) OF
         0..$7F:    { ordinary chars }
            BEGIN
               UnsqSt := UnsqSt + St[Ptr];
               INC(Ptr);
            END;
         $80:       { RLE sequence }
            BEGIN
               UnsqSt := UnsqSt + Dupe((ORD(St[Ptr + 1]) AND $7F) + 3, ' ');
               INC(Ptr, 2);
            END;
         $81..$FF:  { character followed by one space }
            BEGIN
               UnsqSt := UnsqSt + CHR(ORD(St[Ptr]) AND $7F) + ' ';
               INC(Ptr);
            END;
      END;
   BUsq := UnsqSt;
END;



{ encipher or decipher a string }
FUNCTION Cipher (St, Passwd: String): String;
VAR
   SPtr, PPtr: Integer;
BEGIN
   IF Length(Passwd) > 0 THEN BEGIN
      PPtr := 1;
      FOR SPtr := 1 TO Length(St) DO BEGIN
         St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]));
         INC(PPtr);
         IF PPtr > Length(Passwd) THEN
            PPtr := 1;
      END;
   END;
   Cipher := St;
END;



{ encipher or decipher a string, with printable results }
FUNCTION CipherP (St, Passwd: String): String;
VAR
   SPtr, PPtr: Integer;
BEGIN
   IF Length(Passwd) > 0 THEN BEGIN
      PPtr := 1;
      FOR SPtr := 1 TO Length(St) DO BEGIN
         St[SPtr] := CHR(Ord(St[SPtr]) XOR Ord(Passwd[PPtr]) XOR $80);
         INC(PPtr);
         IF PPtr > Length(Passwd) THEN
            PPtr := 1;
      END;
   END;
   CipherP := St;
END;



{ remove adjacent occurrences of a given substring from a string }
FUNCTION Crunch (SubSt, St: String): String;
VAR
   Two: String;
   Posn: Integer;
BEGIN
   IF Length(SubSt) > 0 THEN BEGIN
      Two := SubSt + SubSt;
      REPEAT
         Posn := Pos(Two, St);
         IF Posn > 0 THEN
            Delete(St, Posn, Length(SubSt));
      UNTIL Posn = 0;
   END;
   Crunch := St;
END;



{ form a string of repeated substrings }
FUNCTION Dupe (Count: Integer; SubSt: String): String;
VAR
   St: String;
BEGIN
   St := '';
   WHILE Count > 0 DO BEGIN
      St := St + SubSt;
      DEC(Count);
   END;
   Dupe := St;
END;



{ extract a substring from a string partitioned by delimiters }
FUNCTION Extract (St, Delimiter: String; Index: Integer): String;
VAR
   Start, SLen, Posn: Integer;
BEGIN
   Start := 1;
   IF (Index > 0) AND (Length(Delimiter) > 0) THEN BEGIN
      REPEAT
         Posn := Instr(Start, Delimiter, St);
         DEC(Index);
         IF Index = 0 THEN
            IF Posn > 0 THEN
               SLen := Posn - Start
            ELSE
               SLen := Length(St) - Start + 1
         ELSE IF Posn = 0 THEN
            SLen := 0
         ELSE
            Start := Posn + Length(Delimiter);
      UNTIL (Posn = 0) OR (Index = 0);
   END
   ELSE
      SLen := 0;
   Extract := Copy(St, Start, SLen);
END;



{ search for a substring within a string (like Pos but with start position) }
FUNCTION Instr (Start: Integer; SubSt, St: String): Integer;
VAR
   Posn: Integer;
BEGIN
   Posn := Pos(SubSt, Copy(St, Start, 255));
   IF Posn > 0 THEN
      Posn := Posn + Start - 1;
   Instr := Posn;
END;



{ return part of a string starting from the left side }
FUNCTION Left (St: String; Len: Integer): String;
BEGIN
   Left := Copy(St, 1, Len);
END;



{ trim blanks from the left side of a string }
FUNCTION LTrim (St: String): String;
BEGIN
   WHILE Copy(St, 1, 1) = ' ' DO
      Delete(St, 1, 1);
   LTrim := St;
END;



{ replace a given substring with another }
FUNCTION Replace (OldSubSt, NewSubSt, St: String): String;
VAR
   Tmp: String;
   Posn: Integer;
BEGIN
   IF Length(OldSubSt) > 0 THEN BEGIN
      Tmp := '';
      REPEAT
         Posn := Pos(OldSubSt, St);
         IF Posn > 0 THEN BEGIN
            Tmp := Tmp + Copy(St, 1, Posn - 1) + NewSubSt;
            Delete(St, 1, Posn + Length(OldSubSt) - 1);
         END
         ELSE
            Tmp := Tmp + St;
      UNTIL Posn = 0;
      Replace := Tmp;
   END
   ELSE
      Replace := St;
END;



{ return part of a string starting from the right side }
FUNCTION Right (St: String; Len: Integer): String;
BEGIN
   IF Len >= Length(St) THEN
      Right := St
   ELSE
      Right := Copy(St, Length(St) - Len + 1, 255);
END;



{ search for a substring, starting from the right side of a string }
FUNCTION RPos (SubSt, St: String): Integer;
VAR
   Posn: Integer;
BEGIN
   Posn := Pos(Reverse(SubSt), Reverse(St));
   IF Posn > 0 THEN
      Posn := Length(St) - Length(SubSt) - Posn + 2;
   RPos := Posn;
END;



{ trim blanks from the right side of a string }
FUNCTION RTrim (St: String): String;
BEGIN
   WHILE Copy(St, Length(St), 1) = ' ' DO
      Delete(St, Length(St), 1);
   RTrim := St;
END;



{ strip all occurrences of a list of characters from a string }
FUNCTION StripCh (ChList, St: String): String;
VAR
   Ptr: Integer;
   Tmp: String;
BEGIN
   Tmp := '';
   IF Length(ChList) > 0 THEN
      FOR Ptr := 1 TO Length(St) DO
         IF Pos(St[Ptr], ChList) = 0 THEN
            Tmp := Tmp + St[Ptr];
   StripCh := Tmp;
END;



{ strip all occurrences of a substring from a string }
FUNCTION StripSt (SubSt, St: String): String;
VAR
   Posn: Integer;
BEGIN
   IF (Length(St) = 0) OR (Length(SubSt) = 0) THEN
      StripSt := ''
   ELSE BEGIN
      REPEAT
         Posn := Pos(SubSt, St);
         IF Posn > 0 THEN
            Delete(St, Posn, Length(SubSt));
      UNTIL Posn = 0;
      StripSt := St;
   END;
END;



{ strip all occurrences of given types of character from a string }
FUNCTION StripType (ChType: Integer; St: String): String;
VAR
   Posn: Integer;
BEGIN
   REPEAT
      Posn := TypePos(ChType, St);
      IF Posn > 0 THEN
         Delete(St, Posn, 1);
   UNTIL Posn = 0;
   StripType := St;
END;



{ ----------------------- initialization code --------------------------- }
BEGIN
END.